home *** CD-ROM | disk | FTP | other *** search
/ PD Collection CD 1 / PD Collection CD 1.iso / programer2 / lisp / xlisp / !XLisp / Initialize < prev    next >
Lisp/Scheme  |  1990-02-24  |  3KB  |  89 lines
  1. ; initialization file for XLISP 1.6
  2.  
  3. ; get some more memory
  4. (expand 1)
  5.  
  6. ; some fake definitions for Common Lisp pseudo compatiblity
  7. (setq first  car)
  8. (setq second cadr)
  9. (setq rest   cdr)
  10.  
  11. ; (when test code...) - execute code when test is true
  12. (defmacro when (test &rest code)
  13.           `(cond (,test ,@code)))
  14.  
  15. ; (unless test code...) - execute code unless test is true
  16. (defmacro unless (test &rest code)
  17.           `(cond ((not ,test) ,@code)))
  18.  
  19. ; (makunbound sym) - make a symbol be unbound
  20. (defun makunbound (sym) (setq sym '*unbound*) sym)
  21.  
  22. ; (objectp expr) - object predicate
  23. (defun objectp (x) (eq (type-of x) :OBJECT))
  24.  
  25. ; (filep expr) - file predicate
  26. (defun filep (x) (eq (type-of x) :FILE))
  27.  
  28. ; (unintern sym) - remove a symbol from the oblist
  29. (defun unintern (sym) (cond ((member sym *oblist*)
  30.                              (setq *oblist* (delete sym *oblist*))
  31.                              t)
  32.                             (t nil)))
  33.  
  34. ; (mapcan fun list [ list ]...)
  35. (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  36.  
  37. ; (mapcon fun list [ list ]...)
  38. (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  39.  
  40. ; (set-macro-character ch fun [ tflag ])
  41. (defun set-macro-character (ch fun &optional tflag)
  42.     (setf (aref *readtable* ch) (cons (if tflag :tmacro :nmacro) fun))
  43.     t)
  44.  
  45. ; (get-macro-character ch)
  46. (defun get-macro-character (ch)
  47.   (if (consp (aref *readtable* ch))
  48.     (cdr (aref *readtable* ch))
  49.     nil))
  50.  
  51. ; (save2 fun) - save a function definition to a file
  52. (defmacro save2 (fun)
  53.          `(let* ((fname (strcat "$." (symbol-name ',fun) ))
  54.                  (fval (car ,fun))
  55.                  (fp (openo fname)))
  56.                 (cond (fp (print (cons (if (eq (car fval) 'lambda)
  57.                                            'defun
  58.                                            'defmacro)
  59.                                        (cons ',fun (cdr fval))) fp)
  60.                           (close fp)
  61.                           fname)
  62.                       (t nil))))
  63.   
  64. ; (save fun) - save a function definition to a file
  65. (defmacro save (fun)
  66.          `(let* ((fname (strcat "lisp." (symbol-name ',fun) ))
  67.                  (fval (car ,fun))
  68.                  (fp (openo fname)))
  69.                 (cond (fp (print (cons (if (eq (car fval) 'lambda)
  70.                                            'defun
  71.                                            'defmacro)
  72.                                        (cons ',fun (cdr fval))) fp)
  73.                           (close fp)
  74.                           fname)
  75.                       (t nil))))
  76.  
  77. ; (debug) - enable debug breaks
  78. (defun debug ()
  79.        (setq *breakenable* t))
  80.  
  81. ; (nodebug) - disable debug breaks
  82. (defun nodebug ()
  83.        (setq *breakenable* nil))
  84.  
  85. ; initialize to enable breaks but no trace back
  86. (setq *breakenable* t)
  87. (setq *tracenable* nil)
  88. (print "Initiallization completed")
  89.